home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / dbguser / interface.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  7.6 KB  |  201 lines
  1. structure UserDebugInterface = struct
  2. local  open UserDebugUtil 
  3.        structure U = System.Unsafe 
  4. in
  5.   open System.Control.Debug
  6.  
  7. (** User-level end of interface mechanism. Should match debug/debug.sml *)
  8.   
  9.  (* Data types *)
  10.  (** shared with DebugStatic: *)
  11.  type filename = string 
  12.  type charno = int (* counting from 1 *)
  13.  type location = filename * charno
  14.  type visible = bool  (* true if file has not been hidden by reusing *)
  15.  type time = int
  16.  type place = int 
  17.  
  18.  (** shared with DebugMotions, DebugQueries: *)
  19.  type wherewhen = place * time 
  20.  type value = U.object
  21.  type ty = U.object (* Basics.ty *)
  22.  
  23.  (** shared with DebugMotions: *)
  24.  datatype 'a outcome = COMPLETED of 'a | INTERRUPTED of 'a | NOTRUNNING
  25.  
  26.  (** shared with Debugger: *)
  27.  datatype debuglevel =
  28.        FULL
  29.      | LIVE of ((string * instream) option * (unit -> unit) * (unit -> unit))
  30.      | INTERPOLATION
  31.  
  32.  (** Interface to the debugging functions in the compiler. *)
  33.  
  34.  (* Naming conventions:
  35.  
  36.   X routines are heavy-weight: they take care of establishing and resetting
  37.     times as appropriate, and generally return outcomes to note interrupts.
  38.  
  39.   Y routines typically take a time as argument, and are more fragile; they
  40.     must be called under the protection of an X routine 
  41.     (such as XwithEstablishedTime) to reset times and deal with interrupts.
  42.  
  43.   Z routines generally operate independent of current time/context.
  44.  
  45.   W routines are strictly private, for debugging the debugger.
  46.  *)
  47.  
  48.  exception Oops
  49.  val ZdebugPervEnv:(System.Env.environment ref) = U.cast (!interface 0)
  50.  val Xuse_file:((debuglevel*string)->unit) = !interface 1 
  51.  val Xuse_stream:((debuglevel*instream)->unit) = !interface 2
  52.  val XwithEstablishedTime:((time->'a) -> 'a outcome) = !interface 3 
  53.  val YcurrentTime:(unit->time) = !interface 4 
  54.  val YcurrentPlaces:(unit->place list) = !interface 5 
  55.  val YboundingTimes:(unit->(time*time)) = !interface 6
  56.  val YlastTimes:(place->time*time) = !interface 7 
  57.  val Xjump:(time->wherewhen outcome) = !interface 8 
  58.  val XbinSearch:((unit->time) * time * bool -> wherewhen outcome) = !interface 9
  59.  val YcallTrace:(int->time->((wherewhen*wherewhen*(((string*ty)*value) list)) list)) = !interface 10 
  60.  val YgetVal:(string->time->(value*ty*wherewhen) option) = !interface 11 
  61.  val YprintVal:((value*ty)->unit) = !interface 12  
  62.  val ZisFn:(ty->bool) = !interface 13 
  63.  val YprintBind:((wherewhen*int)->unit) = !interface 14
  64.  val Wdd:bool ref = U.cast !interface 15 
  65.  (* history store stuff uses interface 16 *) 
  66.  val ZeventsAfterLocation:(location -> place list) = !interface 17  
  67.  val ZeventsBeforeLocation:(location -> place list) = !interface 18 
  68.  (* history signals stuff uses interface 19 *) 
  69.  val Xcomplete:(unit->unit outcome) = !interface 20 
  70.  val Xabort:(unit->unit outcome) = !interface 21 
  71.  val ZinDebug:(unit->bool) = !interface 22   
  72.  val Yexception:(unit->exn option) = !interface 23 
  73.  (* history io stuff uses interface 24 *) 
  74.  val ZeventDesc:(place ->(string*bool*location*visible) option) = !interface 25
  75.  val WmaxTimeDelta:int ref = U.cast !interface 26
  76.  val Wtimes:(int array) = U.cast !interface 27
  77.  val Ycaller:(time->(wherewhen*wherewhen)) = !interface 28 
  78.  val Zinfinity:int = U.cast !interface 29 
  79.  val ZsetEnvTime:(time->unit) =  !interface 30  
  80.  val YatCall:(time->bool) = !interface 31
  81.  val WuseSpecial:bool ref = U.cast !interface 32 
  82.  val ZcharnoForLinepos:(filename * int * int) -> charno = U.cast !interface 33
  83.  val Wsizereport: (string->unit) ref = U.cast !interface 34 
  84.  val WinstrumLevel:int ref = U.cast !interface 35 
  85.  val WmemoLevel:int ref = U.cast !interface 36 
  86.  val WdumpCache:(unit -> unit) = !interface 37 
  87.  val Wdfactor:real ref = U.cast !interface 38
  88.  val WexecTime:(unit -> int ref) = !interface 39 
  89.  val WmaxStates:(int ref) = U.cast !interface 40 
  90.  val WpreCachingEnabled:(bool ref) = U.cast !interface 41
  91.  val WcpCost: (int ref) = U.cast !interface 42 
  92.  val Wpcfactor: (real ref) = U.cast !interface 43 
  93.  val WzapFactor: (real ref) = U.cast !interface 44 
  94.  val WstrictLru : (bool ref) = U.cast !interface 45
  95.  val WcacheRatio : (int ref) = U.cast !interface 46
  96.  val WzapCount: (int ref) = U.cast !interface 47 
  97.  val Xinterpolate_stream: (instream->unit) = !interface 48
  98.  val ZdebugCommandsEnv:(System.Env.environment ref) = U.cast (!interface 49)
  99.  val XsetSignal: (System.Signals.signal -> unit) = !interface 50
  100.  val XclearSignal: (System.Signals.signal -> unit) = !interface 51
  101.  val Ysignal: (unit -> (System.Signals.signal option)) = !interface 52
  102.  val ZhaltOnSignal : ((System.Signals.signal * bool) -> unit) = !interface 53
  103.  val YexnArg: (exn -> ((System.Unsafe.object * ty) option)) = !interface 54
  104.  val ZlineposForCharno : location -> (int * int) = !interface 55
  105.  
  106.  (** Useful functions on events, built up from interface functions. *)
  107.  
  108.  fun interruptableQuery (f:time->unit)  =
  109.    (* Suitable for operations that play with time and do text-style output *)
  110.    case (XwithEstablishedTime f) of
  111.      COMPLETED x => x
  112.    | INTERRUPTED _ => System.Print.say "(Interrupted)\n"
  113.    | NOTRUNNING => printNotUnder()
  114.  
  115.  fun safeQuery f  =
  116.    (* Suitable for operations that don't change the time *)
  117.    case (XwithEstablishedTime f) of
  118.      COMPLETED x => x
  119.    | INTERRUPTED x => x
  120.    | NOTRUNNING => raise (DebugUserError "safeQuery")
  121.  
  122.    
  123.  fun establishedTime() = safeQuery (fn t => t)
  124.  fun establishedPlace() = safeQuery (fn _ => hd(YcurrentPlaces()))
  125.  
  126.  fun eventText ev =
  127.      #1 (ensureD(ZeventDesc ev, "eventText"))
  128.  
  129.  fun eventLocation ev : location option =
  130.      case ZeventDesc ev of
  131.        SOME (_,pseudo,filpos,visible) =>
  132.        if (not pseudo) andalso visible then
  133.              SOME filpos
  134.        else NONE
  135.      | NONE => NONE
  136.  
  137.  fun traceEvent (ww:wherewhen) (n:int) : wherewhen option = 
  138.  (* Return the nth caller above the given location, counting that location
  139.   * as 0th. *)
  140.    let fun trace (ww as (_,t:time)) =
  141.          if t > 0 then
  142.        fn 0 => SOME ww
  143.         | n => 
  144.            let val (_,ww) = Ycaller t
  145.            in trace ww (n-1)
  146.            end
  147.      else fn _ => NONE
  148.    in case (XwithEstablishedTime (fn _ => trace ww n)) of
  149.         COMPLETED wwop => wwop
  150.       | INTERRUPTED _ => NONE
  151.       | NOTRUNNING => raise (DebugUserError "traceEvent")
  152.    end
  153.  
  154.  local 
  155.    exception NotAvailable
  156.    fun findEv ev =
  157.    (* Return file, character position for event, "eventsAfter" list 
  158.     * containing event and its position in that list. *)
  159.        case eventLocation ev of
  160.      SOME (loc as (file,cp)) =>
  161.        let val elist = ZeventsAfterLocation loc
  162.            val index =
  163.            case (first (fn x => x = ev) elist) of
  164.              SOME i => i
  165.    (* It is possible that an event will not be found in the list: fine-grained
  166.     * events are sometimes not indexed. In that case, simply move to an
  167.     * event near the fine-grained event. *)
  168.            | NONE => ~1
  169.        in (file,cp,elist,index)
  170.        end
  171.         | _ => raise NotAvailable
  172.  in
  173.  fun prevEvent  ev =
  174.  (* Return the event that lexically  precedes the given event, i.e. the
  175.   * previous event in the source text.  This allows us to sequentially
  176.   * traverse all the events in a compilation unit. *)
  177.      let val (file,cp,elist,index) = findEv ev
  178.      in    
  179.      SOME (nth (elist, index-1 ))
  180.      handle Nth =>
  181.          (SOME (foot (ZeventsBeforeLocation (file, cp - 1)))
  182.           handle Hd => NONE)
  183.      end handle NotAvailable => NONE
  184.  
  185.  fun nextEvent ev =
  186.  (* Return the event that lexically follows the given event, i.e. the next
  187.   * event in the source text.  This allows us to sequentially
  188.   * traverse all the events in a compilation unit. *)
  189.      let val (file,cp,elist,index) = findEv ev
  190.      in
  191.      SOME (nth (elist, index+1))
  192.      handle Nth =>
  193.          (SOME (hd (ZeventsAfterLocation (file, cp + 1)))
  194.           handle Hd => NONE)
  195.      end handle NotAvailable => NONE
  196.  end (* local *)
  197.  
  198. end (* local *)
  199. end (* structure *)
  200.  
  201.